home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / qbsnip.zip / FONTS.ZIP / FONTS.BAS < prev   
BASIC Source File  |  1997-06-20  |  4KB  |  172 lines
  1. ' Font routines written by Luke Molnar
  2.  
  3. DEFINT A-Z
  4.  
  5. '*** Font routines
  6. DECLARE SUB Font (Text$, XStart, Ystart, Xscale, Yscale, Style, clr)
  7. DECLARE SUB LoadFont ()
  8. DECLARE SUB FontPal ()
  9.  
  10. '$STATIC
  11. DIM SHARED FontBuf(0) AS STRING * 10368
  12.  
  13. '$DYNAMIC
  14.  
  15. LoadFont
  16.  
  17. SCREEN 13
  18.  
  19. FontPal
  20. ' Text, xpos, ypos, xscale, yscale, sytle, color
  21. ' Font Styles 1 - 4:
  22. '  1 = Pin Stripe
  23. '  2 = Steel Grating
  24. '  3 = Normal Fade
  25. '  4 = Italic Fade
  26. Font "Hello World", 0, 75, 3, 3, 3, 65
  27. P$ = INPUT$(1)
  28.  
  29. SCREEN 0, 0, 0, 0: WIDTH 80: COLOR 7, 0: CLS : END
  30.  
  31. REM $STATIC
  32. SUB Font (Text$, XStart, Ystart, Xscale, Yscale, Style, clr)
  33.  
  34. px = XStart  ' physical x and physical y
  35. py = Ystart
  36.  
  37. LHeight = Yscale * 8
  38. Optimize = 63 \ LHeight ' Any constant math operations done multipe times
  39.                           ' in the main loop should, well, not be done
  40.                           ' in the main loop.
  41.  
  42.  
  43. ' Instead of wasting our time with all this MID$ garbage to access bytes in
  44. ' font buffer, we'll just take a PEEK directly at them.
  45. DEF SEG = VARSEG(FontBuf(0))
  46.  
  47.  FOR h = 1 TO LEN(Text$)
  48.   FPtr = 81 * (ASC(MID$(Text$, h, 1)) - 1) - 1
  49.   FOR x = 0 TO 8
  50.    FOR y = 0 TO 8
  51.  
  52.     col = PEEK(VARPTR(FontBuf(0)) + FPtr)
  53.     FPtr = FPtr + 1
  54.     IF col THEN
  55.      SELECT CASE Style
  56.       ' If you desire a y scale factor greater than 8, you
  57.       ' must change the division to higher precision...very slow.
  58.       ' Or, you could find a way around it.
  59.       CASE 1: PSET (px, py), Optimize * (py - Ystart) + clr
  60.               LINE (px, py)-(px, py + Yscale), Optimize * (py - Ystart) + clr
  61.       ' Notice how this style only uses 54 colors, so you can see the top
  62.       ' of the letters where they would normally be black
  63.       CASE 2: CIRCLE (px, py), Yscale, (54 \ LHeight) * (py - Ystart) + clr + 9, , , 4
  64.       CASE 3:  FOR sty = px TO px + Xscale
  65.                 FOR sty2 = py TO py + Yscale
  66.                  PSET (sty, sty2), Optimize * (sty2 - Ystart) + clr
  67.                  IF POINT(sty - 1, sty2) = 0 THEN PSET (sty - 1, sty2), 63 + clr - 1
  68.                  IF POINT(sty, sty2 - 1) = 0 THEN PSET (sty, sty2 - 1), 63 + clr - 1
  69.                 NEXT
  70.                NEXT
  71.        CASE 4: FOR sty = px TO px + Xscale
  72.                 FOR sty2 = py TO py + Yscale
  73.                  PSET (sty + .4 * sty2, sty2), Optimize * (sty2 - Ystart) + clr
  74.                  IF POINT((sty - 1) + .4 * sty2, sty2) = 0 THEN PSET ((sty - 1) + .4 * sty2, sty2), 63 + clr - 1
  75.                 NEXT
  76.                NEXT
  77.        CASE ELSE
  78.             PSET (px, py), clr
  79.      END SELECT
  80.     END IF
  81.     py = py + Yscale
  82.    NEXT
  83.   px = px + Xscale
  84.   py = Ystart
  85.   NEXT
  86.  NEXT h
  87. DEF SEG
  88.  
  89. END SUB
  90.  
  91. SUB FontPal
  92. FOR x = 1 TO 63
  93.  OUT &H3C8, x
  94.  OUT &H3C9, x
  95.  OUT &H3C9, 0
  96.  OUT &H3C9, 0
  97. NEXT
  98. FOR x = 64 TO 126
  99.  OUT &H3C8, x
  100.  OUT &H3C9, 0
  101.  OUT &H3C9, x
  102.  OUT &H3C9, 0
  103. NEXT
  104. FOR x = 127 TO Sclr + 189
  105.  OUT &H3C8, x
  106.  OUT &H3C9, 0
  107.  OUT &H3C9, 0
  108.  OUT &H3C9, x
  109. NEXT
  110. FOR x = 190 TO 252
  111.  OUT &H3C8, x
  112.  OUT &H3C9, x
  113.  OUT &H3C9, 0
  114.  OUT &H3C9, x
  115. NEXT
  116. FOR x = 253 TO 255
  117.  OUT &H3C8, x
  118.  OUT &H3C9, x
  119.  OUT &H3C9, x
  120.  OUT &H3C9, x
  121. NEXT
  122. END SUB
  123.  
  124. SUB LoadFont
  125.  
  126.    fontfile = FREEFILE
  127.  
  128.    OPEN "basefont.dat" FOR BINARY AS #fontfile
  129.  
  130.    IF LOF(fontfile) < 20655 THEN
  131.       SCREEN 0: WIDTH 80, 25
  132.       COLOR 7
  133.       PRINT "Font data file missing or corrupt.  Rebuild it? [(Y)/n]";
  134.       DO
  135.          key$ = UCASE$(INKEY$)
  136.       LOOP UNTIL key$ = "N" OR key$ = "Y"
  137.       CLOSE fontfile
  138.       IF key$ = "N" THEN EXIT SUB
  139.       'MakeFont
  140.       fontfile = FREEFILE
  141.  
  142.       OPEN "basefont.dat" FOR BINARY AS #fontfile
  143.       ' Hey, change 128 to 255 for the full font.
  144.       CLS
  145.       SCREEN 13
  146.       COLOR 16
  147.       FOR ascii = 1 TO 255
  148.         CLS
  149.         PRINT CHR$(ascii)
  150.         FOR x = 0 TO 8
  151.           FOR y = 0 TO 8
  152.             pnt$ = CHR$(POINT(x, y))
  153.             PUT #fontfile, , pnt$
  154.             pnt$ = ""
  155.           NEXT
  156.         NEXT
  157.       NEXT
  158.       CLOSE
  159.      
  160.       OPEN "basefont.dat" FOR BINARY AS #fontfile
  161.       GET #fontfile, , FontBuf(0)
  162.       CLOSE #fontfile
  163.  
  164.       fontfile = FREEFILE
  165.       OPEN "basefont.dat" FOR BINARY AS #fontfile
  166.    END IF
  167.  
  168.    GET #fontfile, , FontBuf(0)
  169.    CLOSE #fontfile
  170. END SUB
  171.  
  172.